home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / hcodegen.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  10KB  |  326 lines
  1. {
  2.     $Id: hcodegen.pas,v 1.1.1.1 1998/03/25 11:18:13 root Exp $
  3.     Copyright (c) 1996-98 by Florian Klaempfl
  4.  
  5.     This unit exports some help routines for the code generation
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit hcodegen;
  24.  
  25.   interface
  26.  
  27.      uses
  28.         cobjects,systems,globals,tree,symtable,types,strings,aasm
  29. {$ifdef i386}
  30.        ,i386
  31. {$endif}
  32. {$ifdef m68k}
  33.        ,m68k
  34. {$endif}
  35.        ;
  36.  
  37.     const
  38.        { set, if the procedure uses asm }
  39.        pi_uses_asm = $1;
  40.        { set, if the procedure is exported by an unit }
  41.        pi_is_global = $2;
  42.        { set, if the procedure does a call }
  43.        { this is for the optimizer         }
  44.        pi_do_call = $4;
  45.        { if the procedure is an operator   }
  46.        pi_operator = $8;
  47.        { set, if the procedure is an external C function }
  48.        pi_C_import = $10;
  49.  
  50.     type
  51.        pprocinfo = ^tprocinfo;
  52.  
  53.        tprocinfo = record
  54.           { pointer to parent in nested procedures }
  55.           parent : pprocinfo;
  56.           { current class, if we are in a method }
  57.           _class : pobjectdef;
  58.           { return type }
  59.           retdef : pdef;
  60.           { frame pointer offset }
  61.           framepointer_offset : longint;
  62.           { self pointer offset }
  63.           ESI_offset : longint;
  64.           { result value offset }
  65.           retoffset : longint;
  66.  
  67.           { firsttemp position }
  68.           firsttemp : longint;
  69.  
  70.           funcret_is_valid : boolean;
  71.  
  72.           { parameter offset }
  73.           call_offset : longint;
  74.  
  75.           { some collected informations about the procedure }
  76.           { see pi_xxxx above                               }
  77.           flags : longint;
  78.  
  79.           { register used as frame pointer }
  80.           framepointer : tregister;
  81.  
  82. {$ifdef GDB}
  83.           { true, if the procedure is exported by an unit }
  84.           globalsymbol : boolean;
  85. {$endif * GDB *}
  86.  
  87.           { true, if the procedure should be exported (only OS/2) }
  88.           exported : boolean;
  89.  
  90.           { code for the current procedure }
  91.           aktproccode,aktentrycode,aktexitcode : paasmoutput;
  92.        end;
  93.  
  94.     var
  95.        { info about the current sub routine }
  96.        procinfo : tprocinfo;
  97.  
  98.        { Die Nummer der Label die bei BREAK bzw CONTINUE }
  99.        { angesprungen werden sollen }
  100.        aktbreaklabel,aktcontinuelabel : plabel;
  101.  
  102.        { truelabel wird angesprungen, wenn ein Ausdruck true ist, falselabel }
  103.        { entsprechend                                                        }
  104.        truelabel,falselabel : plabel;
  105.  
  106.        { Nr des Labels welches zum Verlassen eines Unterprogramm }
  107.        { angesprungen wird                                       }
  108.        aktexitlabel : plabel;
  109.  
  110.        { also an exit label, only used we need to clear only the }
  111.        { stack                                                   }
  112.        aktexit2label : plabel;
  113.  
  114.        { only used in constructor for fail or if getmem fails }
  115.        quickexitlabel : plabel;
  116.  
  117.        { this asm list contains the debug info }
  118.        {debuginfos : paasmoutput;  debuglist is enough }
  119.  
  120.        { Boolean, wenn eine loadn kein Assembler erzeugt hat }
  121.        simple_loadn : boolean;
  122.  
  123.        { enth„lt die gesch„tzte Durchlaufanzahl*100 fr den }
  124.        { momentan bearbeiteten Baum                         }
  125.        t_times : longint;
  126.  
  127.        { true, if an error while code generation occurs }
  128.        codegenerror : boolean;
  129.  
  130.     { some support routines for the case instruction }
  131.  
  132.     { counts the labels }
  133.     function case_count_labels(root : pcaserecord) : longint;
  134.  
  135.     { searches the highest label }
  136.     function case_get_max(root : pcaserecord) : longint;
  137.  
  138.     { searches the lowest label }
  139.     function case_get_min(root : pcaserecord) : longint;
  140.  
  141.     { concates the ASCII string to the const segment }
  142.     procedure generate_ascii(hs : string);
  143.  
  144.     { inserts the ASCII string to the const segment }
  145.     procedure generate_ascii_insert(hs : string);
  146.  
  147.     procedure generate_interrupt_stackframe_entry;
  148.     procedure generate_interrupt_stackframe_exit;
  149.  
  150.   implementation
  151.  
  152. {$ifdef i386}
  153.     procedure generate_interrupt_stackframe_entry;
  154.  
  155.       begin
  156.          { save the registers of an interrupt procedure }
  157.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EAX)));
  158.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EBX)));
  159.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_ECX)));
  160.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EDX)));
  161.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
  162.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EDI)));
  163.  
  164.          { .... also the segment registers }
  165.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_DS)));
  166.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_ES)));
  167.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_FS)));
  168.          procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_GS)));
  169.       end;
  170.  
  171.     procedure generate_interrupt_stackframe_exit;
  172.  
  173.       begin
  174.          { restore the registers of an interrupt procedure }
  175.          { this was all with entrycode instead of exitcode !!}
  176.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX)));
  177.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EBX)));
  178.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_ECX)));
  179.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EDX)));
  180.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_ESI)));
  181.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI)));
  182.  
  183.          { .... also the segment registers }
  184.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_DS)));
  185.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_ES)));
  186.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_FS)));
  187.          procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_GS)));
  188.  
  189.         { this restores the flags }
  190.          procinfo.aktexitcode^.concat(new(pai386,op_none(A_IRET,S_NO)));
  191.       end;
  192. {$endif}
  193. {$ifdef m68k}
  194.     procedure generate_interrupt_stackframe_entry;
  195.       begin
  196.          { save the registers of an interrupt procedure }
  197.  
  198.          { .... also the segment registers }
  199.       end;
  200.  
  201.     procedure generate_interrupt_stackframe_exit;
  202.  
  203.       begin
  204.          { restore the registers of an interrupt procedure }
  205.       end;
  206. {$endif}
  207.  
  208.     procedure generate_ascii(hs : string);
  209.  
  210.       begin
  211.          while length(hs)>32 do
  212.            begin
  213.               datasegment^.concat(new(pai_string,init(copy(hs,1,32))));
  214.               delete(hs,1,32);
  215.            end;
  216.          datasegment^.concat(new(pai_string,init(hs)))
  217.       end;
  218.  
  219.     procedure generate_ascii_insert(hs : string);
  220.  
  221.       begin
  222.          while length(hs)>32 do
  223.            begin
  224.               datasegment^.insert(new(pai_string,init(copy(hs,length(hs)-32+1,length(hs)))));
  225.               delete(hs,length(hs)-32+1,length(hs));
  226.            end;
  227.          datasegment^.insert(new(pai_string,init(hs)));
  228.       end;
  229.  
  230.     function case_count_labels(root : pcaserecord) : longint;
  231.  
  232.       var
  233.          _l : longint;
  234.  
  235.       procedure count(p : pcaserecord);
  236.  
  237.         begin
  238.            inc(_l);
  239.            if assigned(p^.less) then
  240.              count(p^.less);
  241.            if assigned(p^.greater) then
  242.              count(p^.greater);
  243.         end;
  244.  
  245.       begin
  246.          _l:=0;
  247.          count(root);
  248.          case_count_labels:=_l;
  249.       end;
  250.  
  251.     function case_get_max(root : pcaserecord) : longint;
  252.  
  253.       var
  254.          hp : pcaserecord;
  255.  
  256.       begin
  257.          hp:=root;
  258.          while assigned(hp^.greater) do
  259.            hp:=hp^.greater;
  260.          case_get_max:=hp^._high;
  261.       end;
  262.  
  263.     function case_get_min(root : pcaserecord) : longint;
  264.  
  265.       var
  266.          hp : pcaserecord;
  267.  
  268.       begin
  269.          hp:=root;
  270.          while assigned(hp^.less) do
  271.            hp:=hp^.less;
  272.          case_get_min:=hp^._low;
  273.       end;
  274.  
  275. end.
  276.  
  277. {
  278.   $Log: hcodegen.pas,v $
  279.   Revision 1.1.1.1  1998/03/25 11:18:13  root
  280.   * Restored version
  281.  
  282.   Revision 1.6  1998/03/10 16:27:38  pierre
  283.     * better line info in stabs debug
  284.     * symtabletype and lexlevel separated into two fields of tsymtable
  285.     + ifdef MAKELIB for direct library output, not complete
  286.     + ifdef CHAINPROCSYMS for overloaded seach across units, not fully
  287.       working
  288.     + ifdef TESTFUNCRET for setting func result in underfunction, not
  289.       working
  290.  
  291.   Revision 1.5  1998/03/10 01:17:19  peter
  292.     * all files have the same header
  293.     * messages are fully implemented, EXTDEBUG uses Comment()
  294.     + AG... files for the Assembler generation
  295.  
  296.   Revision 1.4  1998/03/02 01:48:37  peter
  297.     * renamed target_DOS to target_GO32V1
  298.     + new verbose system, merged old errors and verbose units into one new
  299.       verbose.pas, so errors.pas is obsolete
  300.  
  301.   Revision 1.3  1998/02/13 10:35:03  daniel
  302.   * Made Motorola version compilable.
  303.   * Fixed optimizer
  304.  
  305.   Revision 1.2  1998/01/16 18:03:15  florian
  306.     * small bug fixes, some stuff of delphi styled constructores added
  307.  
  308.   Revision 1.1.1.1  1997/11/27 08:32:56  michael
  309.   FPC Compiler CVS start
  310.  
  311.   Pre-CVS log:
  312.  
  313.   CEC   Carl-Eric Codere
  314.   FK    Florian Klaempfl
  315.   PM    Pierre Muller
  316.   +     feature added
  317.   -     removed
  318.   *     bug fixed or changed
  319.  
  320.   History:
  321.        5th september 1997:
  322.          + added support for MC68000 (CEC)
  323.       22th september 1997:
  324.          + added tprocinfo member parent (FK)
  325. }
  326.